{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TypeSynonymInstances       #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  WumpusExpr.TopLevel
-- Copyright   :  (c) Stephen Tetley 2012
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- Syntax.
--
--------------------------------------------------------------------------------

module WumpusExpr.TopLevel
  ( 

  -- These ones are temporary...

  -- end of temporary exports

    ReflectType       -- opaque - for signatures only!
  , WM
  , WBool
  , WInt
  , WUnit
  , WFloat

  , defFun0
  , funApply0
  , defFun1
  , funApply1
  , defFun2
  , funApply2
  , defFun3
  , funApply3
  , defFun4
  , funApply4
  
  , letv
  , ifte

  , wnot
  , (*&&)
  , (*||)

  , (&==)
  , (&/=)
  , (&<)
  , (&>)
  , (&<=)
  , (&>=)

  , string
  , unit
  , true
  , false

  , (>>>)

  -- * Commands
  , newpath
  , closepath
  , fill
  , stroke
  , moveto
  , lineto
  , curveto
  , gsave
  , grestore
  , scale
  , rotate
  , translate
  , transform
  , showtext

  ) where

import WumpusExpr.Operators
import WumpusExpr.Radian
import WumpusExpr.Syntax
import WumpusExpr.Types
import WumpusExpr.VarId

import Control.Applicative

-- | WM - wumpus monad.
--
newtype WMon a = WMon { getWMon :: Int -> (a,Int) }

instance Functor WMon where
  fmap f ma = WMon $ \s -> let (a,s1) = getWMon ma s in (f a,s1)

instance Applicative WMon where
  pure a    = WMon $ \s -> (a,s)
  mf <*> ma = WMon $ \s -> let (f,s1) = getWMon mf s
                               (a,s2) = getWMon ma s1
                           in (f a,s2)

instance Monad WMon where
  return    = pure
  ma >>= k  = WMon $ \s -> let (a,s1) = getWMon ma s in getWMon (k a) s1


runW :: WExpr a -> Expr
runW wa = fst $ getWMon (getWExpr wa) 1

newVar :: Type -> WMon VarId
newVar ty = WMon $ \s -> (SynthId s ty, s+1)


-- Phantoms

newtype WExpr a = WExpr { getWExpr :: WMon Expr }


type WBool      = WExpr Bool
type WInt       = WExpr Int
type WFloat     = WExpr Decimal
type WRadian    = WExpr Radian

type WString    = WExpr String
type WUnit      = WExpr ()

data Mon t

type WM a       = WExpr (Mon a)


class ReflectType ty where
  reflectType :: ty -> Type


-- All reflectable types are first order!


instance ReflectType () where
  reflectType _ = TyUnit

instance ReflectType Bool where
  reflectType _ = TyBool

instance ReflectType Int where
  reflectType _ = TyInt

instance ReflectType Decimal where
  reflectType _ = TyFloat

instance ReflectType Radian where
  reflectType _ = TyRadian

instance ReflectType (Mon ()) where
  reflectType _ = TyMon TyUnit

instance ReflectType (Mon Bool) where
  reflectType _ = TyMon TyBool

instance ReflectType (Mon Int) where
  reflectType _ = TyMon TyInt

instance ReflectType (Mon Decimal) where
  reflectType _ = TyMon TyFloat

instance ReflectType (Mon Radian) where
  reflectType _ = TyMon TyRadian


-- WM is a bit useless being a only a type, it does not allow
-- a Monad instance. 



liftW1  :: (Expr -> Expr) -> WExpr r1  -> WExpr a
liftW1 fn (WExpr e1) = WExpr $ liftA fn e1

liftW2 :: (Expr -> Expr -> Expr) -> WExpr r1 -> WExpr r2 -> WExpr a
liftW2 fn (WExpr e1) (WExpr e2) = WExpr $ liftA2 fn e1 e2


instance Num WInt where
  (+) = liftW2 (BinE ADD)
  (-) = liftW2 (BinE SUB)
  (*) = liftW2 (BinE MUL)
  abs _     = error $ "abs - no implementation for WInt"
  signum _  = error $ "signum - no implementation for WInt"
  fromInteger i = WExpr $ pure $ Int $ fromInteger i


-- No - instance Integral WInt
-- We can\'t readily define an Enum instance, so we have to do
-- without div.


instance Num WFloat where
  (+) = liftW2 (BinE ADD)
  (-) = liftW2 (BinE SUB)
  (*) = liftW2 (BinE MUL)
  abs _     = error $ "abs - no implementation for WFloat"
  signum _  = error $ "signum - no implementation for WFloat"
  fromInteger i = WExpr $ pure $ Float $ fromInteger i

instance Fractional WFloat where
  (/) = liftW2 (BinE DIV)
  recip     = error $ "recip - no implementation for WFloat"
  fromRational d = WExpr $ pure $ Float $ fromRational d

instance Num WRadian where
  (+) = liftW2 (BinE ADD)
  (-) = liftW2 (BinE SUB)
  (*) = liftW2 (BinE MUL)
  abs _     = error $ "abs - no implementation for WRadian"
  signum _  = error $ "signum - no implementation for WRadian"
  fromInteger i = WExpr $ pure $ Angle $ fromInteger i

instance Fractional WRadian where
  (/) = liftW2 (BinE DIV)
  recip     = error $ "recip - no implementation for WRadian"
  fromRational d = WExpr $ pure $ Angle $ fromRational d

-- Fractional etc...



-- Arity 0

defFun0 :: forall a. (ReflectType a) 
         => String -> WExpr a -> Fundef
defFun0 name body = Fundef 
    { fun_name       = PrimId name funty
    , fun_args       = []
    , fun_body       = runW body
    } 
  where
    funty   = TyFun [] (reflectType (undefined :: a))


funApply0 :: Fundef -> WExpr a
funApply0 (Fundef { fun_name = vid }) = WExpr $ 
    pure $ App (Var $ PrimId (varName vid) (varType vid)) []

-- Arity 1

defFun1 :: forall r1 a. 
           (ReflectType r1, ReflectType a) 
        => String
        -> (WExpr r1 -> WExpr a)
        -> Fundef
defFun1 name body = Fundef 
    { fun_name  = PrimId name funty
    , fun_args  = [arg1]
    , fun_body  = runW $ body (bodyArg arg1)
    } 
  where
    bodyArg = WExpr . pure . Var
    ty1     = reflectType (undefined :: r1)
    funty   = TyFun [ty1] (reflectType (undefined :: a))
    arg1    = PrimId "arg1" ty1

funApply1 :: Fundef -> (WExpr r1 -> WExpr a)
funApply1 (Fundef { fun_name = vid }) wa = WExpr $ 
    (\e1 -> App (Var $ PrimId (varName vid) (varType vid)) [e1])
      <$> getWExpr wa

-- Arity 2

defFun2 :: forall r1 r2 a. 
           (ReflectType r1, ReflectType r2, ReflectType a) 
        => String
        -> (WExpr r1 -> WExpr r2 -> WExpr a)
        -> Fundef
defFun2 name body = Fundef 
    { fun_name  = PrimId name funty
    , fun_args  = [arg1, arg2]
    , fun_body  = runW $ body (bodyArg arg1) (bodyArg arg2)
    } 
  where
    bodyArg = WExpr . pure . Var
    ty1     = reflectType (undefined :: r1)
    ty2     = reflectType (undefined :: r2)
    funty   = TyFun [ty1,ty2] (reflectType (undefined :: a))
    arg1    = PrimId "arg1" ty1
    arg2    = PrimId "arg2" ty2

funApply2 :: Fundef -> (WExpr r1 -> WExpr r2 -> WExpr a)
funApply2 (Fundef { fun_name = vid })  wa wb = WExpr $ 
    (\e1 e2 -> App (Var $ PrimId (varName vid) (varType vid)) [e1,e2])
      <$> getWExpr wa <*> getWExpr wb

-- Arity 3


defFun3 :: forall r1 r2 r3 a. 
           (ReflectType r1, ReflectType r2, ReflectType r3, ReflectType a) 
        => String
        -> (WExpr r1 -> WExpr r2 -> WExpr r3 -> WExpr a)
        -> Fundef
defFun3 name body = Fundef 
    { fun_name  = PrimId name funty
    , fun_args  = [arg1, arg2, arg3]
    , fun_body  = runW $ body (bodyArg arg1) (bodyArg arg2) (bodyArg arg3)
    } 
  where
    bodyArg = WExpr . pure . Var
    ty1     = reflectType (undefined :: r1)
    ty2     = reflectType (undefined :: r2)
    ty3     = reflectType (undefined :: r3)
    funty   = TyFun [ty1,ty2,ty3] (reflectType (undefined :: a))
    arg1    = PrimId "arg1" ty1
    arg2    = PrimId "arg2" ty2
    arg3    = PrimId "arg3" ty3


funApply3 :: Fundef -> (WExpr r1 -> WExpr r2 -> WExpr r3 -> WExpr a)
funApply3 (Fundef { fun_name = vid })  wa wb wc = WExpr $ 
    (\e1 e2 e3 -> App (Var $ PrimId (varName vid) (varType vid)) [e1,e2,e3])
      <$> getWExpr wa <*> getWExpr wb <*> getWExpr wc





-- Arity 4


defFun4 :: forall r1 r2 r3 r4 a. 
           (ReflectType r1, ReflectType r2, ReflectType r3, ReflectType r4,
            ReflectType a) 
        => String
        -> (WExpr r1 -> WExpr r2 -> WExpr r3 -> WExpr r4 -> WExpr a)
        -> Fundef
defFun4 name body = Fundef 
    { fun_name  = PrimId name funty
    , fun_args  = [arg1, arg2, arg3, arg4]
    , fun_body  = runW $ body (bodyArg arg1) (bodyArg arg2) 
                              (bodyArg arg3) (bodyArg arg4)
    } 
  where
    bodyArg = WExpr . pure . Var
    ty1     = reflectType (undefined :: r1)
    ty2     = reflectType (undefined :: r2)
    ty3     = reflectType (undefined :: r3)
    ty4     = reflectType (undefined :: r4)
    funty   = TyFun [ty1,ty2,ty3,ty4] (reflectType (undefined :: a))
    arg1    = PrimId "arg1" ty1
    arg2    = PrimId "arg2" ty2
    arg3    = PrimId "arg3" ty3
    arg4    = PrimId "arg4" ty4


funApply4 :: Fundef 
          -> (WExpr r1 -> WExpr r2 -> WExpr r3 -> WExpr r4 -> WExpr a)
funApply4 (Fundef { fun_name = vid }) wa wb wc wd = WExpr $ 
    (\e1 e2 e3 e4 -> App (Var $ PrimId (varName vid) (varType vid)) 
                         [e1,e2,e3, e4])
      <$> getWExpr wa <*> getWExpr wb <*> getWExpr wc <*> getWExpr wd





-- Although letE is monadic (needs fresh var) its (Haskell) type
-- signature should look pure...

letv :: WExpr t -> (WExpr t -> WExpr t1) -> WExpr t1
letv (WExpr e) fn = WExpr $ do 
    e1 <- e 
    v1 <- newVar (typeOf e1)
    body <- getWExpr $ fn (WExpr $ pure $ Var v1)
    return $ Let v1 e1 body

ifte :: WBool -> WExpr a -> WExpr a -> WExpr a
ifte wtest wt wf = WExpr $ 
    Ifte <$> getWExpr wtest <*> getWExpr wt <*> getWExpr wf


wnot :: WBool -> WBool
wnot = liftW1 (UnaryE BNOT)



-- Umm - Ifte in syntax should be able to handle this but need
-- to check...


infixr 3 *&&

(*&&) :: WBool -> WBool -> WBool 
(*&&) = liftW2 (BinE LOG_AND)


infixr 2 *||

(*||) :: WBool -> WBool -> WBool 
(*||) = liftW2 (BinE LOG_OR)


-- Note - cannot use Ord as need ans type WBool not Bool

infix 4 &==

(&==) :: Ord a => WExpr a -> WExpr a -> WBool
(&==) = liftW2 (RelE EQU)

infix 4 &/=

(&/=) :: Ord a => WExpr a -> WExpr a -> WBool
(&/=) = liftW2 (RelE NOT_EQU)


infix 4 &<

(&<) :: Ord a => WExpr a -> WExpr a -> WBool
(&<) = liftW2 (RelE LTHAN)

infix 4 &>

(&>) :: Ord a => WExpr a -> WExpr a -> WBool
(&>) = liftW2 (RelE GTHAN)


infix 4 &<=

(&<=) :: Ord a => WExpr a -> WExpr a -> WBool
(&<=) = liftW2 (RelE LT_EQU)

infix 4 &>=

(&>=) :: Ord a => WExpr a -> WExpr a -> WBool
(&>=) = liftW2 (RelE GT_EQU)



(>>>) :: WM b -> WM a -> WM a
(>>>) wa wb = WExpr $ 
    (:>>) <$> getWExpr wa <*> getWExpr wb



string :: String -> WString
string = WExpr . pure . String

unit :: WUnit
unit = WExpr $ pure Unit


true :: WBool
true = WExpr $ pure $ Bool True

false :: WBool
false = WExpr $ pure $ Bool False




command :: Command ->  WM ()
command cmd = WExpr $ pure $ Cmd cmd

command1 :: (Expr -> Command) -> WExpr a ->  WM ()
command1 fn wa = WExpr $ 
    (Cmd . fn) <$> getWExpr wa


command2 :: (Expr -> Expr -> Command) -> WExpr a -> WExpr a ->  WM ()
command2 fn wa wb = WExpr $ 
    (\e1 e2 -> Cmd $ fn e1 e2) <$> getWExpr wa <*> getWExpr wb



command6 :: (Expr -> Expr -> Expr -> Expr -> Expr -> Expr -> Command) 
         -> WExpr a -> WExpr a -> WExpr a -> WExpr a -> WExpr a -> WExpr a
         ->  WM ()
command6 fn wa wb wc wd we wf = WExpr $ 
    (\e1 e2 e3 e4 e5 e6 -> Cmd $ fn e1 e2 e3 e4 e5 e6)
      <$> getWExpr wa <*> getWExpr wb <*> getWExpr wc
      <*> getWExpr wd <*> getWExpr we <*> getWExpr wf


newpath         :: WM ()
newpath         = command NewPath

closepath       :: WM ()
closepath       = command NewPath

fill            :: WM ()
fill            = command Fill

stroke          :: WM ()
stroke          = command Stroke

moveto          :: WFloat -> WFloat -> WM ()
moveto          = command2 MoveTo 

lineto          :: WFloat -> WFloat -> WM ()
lineto          = command2 LineTo 

curveto         :: WFloat -> WFloat -> WFloat -> WFloat -> WFloat -> WFloat 
                -> WM ()
curveto         = command6 CurveTo

gsave           :: WM ()
gsave           = command GSave

grestore        :: WM ()
grestore        = command GRestore

scale           :: WFloat -> WFloat -> WM ()
scale           = command2 Scale

rotate          :: WRadian -> WM ()
rotate          = command1 Rotate

translate       :: WFloat -> WFloat -> WM ()
translate       = command2 Translate


transform       :: WFloat -> WFloat -> WFloat -> WFloat -> WFloat -> WFloat
                -> WM ()
transform       = command6 Transform

showtext        :: WString -> WM ()
showtext        = command1 ShowText